home *** CD-ROM | disk | FTP | other *** search
/ Amiga Format CD 41 / Amiga Format CD41 (1999-06)(Future Publishing)(GB)[!][issue 1999-07].iso / -seriously_amiga- / programming / other / scm / slib / formatst.scm < prev    next >
Text File  |  1999-04-19  |  21KB  |  648 lines
  1. ;; "formatst.scm" SLIB FORMAT Version 3.0 conformance test
  2. ; Written by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de)
  3. ;
  4. ; This code is in the public domain.
  5.  
  6. ;; Test run: (slib:load "formatst")
  7.  
  8. ; Failure reports for various scheme interpreters:
  9. ;
  10. ; SCM4d 
  11. ;   None.
  12. ; Elk 2.2:
  13. ;   None.
  14. ; MIT C-Scheme 7.1:
  15. ;   The empty list is always evaluated as a boolean and consequently
  16. ;   represented as `#f'.
  17. ; Scheme->C 01nov91:
  18. ;   None, if format:symbol-case-conv and format:iobj-case-conv are set
  19. ;   to string-downcase. 
  20.  
  21. (require 'format)
  22. (if (not (string=? format:version "3.0"))
  23.     (begin
  24.       (display "You have format version ")
  25.       (display format:version)
  26.       (display ". This test is for format version 3.0!")
  27.       (newline)
  28.       (format:abort)))
  29.  
  30. (define fails 0)
  31. (define total 0)
  32. (define test-verbose #f)        ; shows each test performed
  33.  
  34. (define (test format-args out-str)
  35.   (set! total (+ total 1))
  36.   (if (not test-verbose)
  37.       (if (zero? (modulo total 10))
  38.           (begin
  39.             (display total)
  40.             (display ",")
  41.         (force-output (current-output-port)))))
  42.   (let ((format-out (apply format `(#f ,@format-args))))
  43.     (if (string=? out-str format-out)
  44.     (if test-verbose
  45.         (begin
  46.           (display "Verified ")
  47.           (write format-args)
  48.           (display " returns ")
  49.           (write out-str)
  50.           (newline)))
  51.     (begin
  52.       (set! fails (+ fails 1))
  53.       (if (not test-verbose) (newline))
  54.       (display "*Failed* ")
  55.       (write format-args)
  56.       (newline)
  57.       (display " returns  ")
  58.       (write format-out)
  59.       (newline)
  60.       (display " expected ")
  61.       (write out-str)
  62.       (newline)))))
  63.  
  64. ; ensure format default configuration
  65.  
  66. (set! format:symbol-case-conv #f)
  67. (set! format:iobj-case-conv #f)
  68. (set! format:read-proof #f)
  69.  
  70. (format #t "~q")
  71.  
  72. (format #t "This implementation has~@[ no~] flonums ~
  73.             ~:[but no~;and~] complex numbers~%"
  74.     (not format:floats) format:complex-numbers)
  75.  
  76. ; any object test
  77.  
  78. (test '("abc") "abc")
  79. (test '("~a" 10) "10")
  80. (test '("~a" -1.2) "-1.2")
  81. (test '("~a" a) "a")
  82. (test '("~a" #t) "#t")
  83. (test '("~a" #f) "#f")
  84. (test '("~a" "abc") "abc")
  85. (test '("~a" '#(1 2 3)) "#(1 2 3)")
  86. (test '("~a" ()) "()")
  87. (test '("~a" (a)) "(a)")
  88. (test '("~a" (a b)) "(a b)")
  89. (test '("~a" (a (b c) d)) "(a (b c) d)")
  90. (test '("~a" (a . b)) "(a . b)")
  91. (test '("~a" (a (b c . d))) "(a (b . (c . d)))") ; this is ugly
  92. (test `("~a" ,display) (format:iobj->str display))
  93. (test `("~a" ,(current-input-port)) (format:iobj->str (current-input-port)))
  94. (test `("~a" ,(current-output-port)) (format:iobj->str (current-output-port)))
  95.  
  96. ; # argument test
  97.  
  98. (test '("~a ~a" 10 20) "10 20")
  99. (test '("~a abc ~a def" 10 20) "10 abc 20 def")
  100.  
  101. ; numerical test
  102.  
  103. (test '("~d" 100) "100")
  104. (test '("~x" 100) "64")
  105. (test '("~o" 100) "144")
  106. (test '("~b" 100) "1100100")
  107. (test '("~@d" 100) "+100")
  108. (test '("~@d" -100) "-100")
  109. (test '("~@x" 100) "+64")
  110. (test '("~@o" 100) "+144")
  111. (test '("~@b" 100) "+1100100")
  112. (test '("~10d" 100) "       100")
  113. (test '("~:d" 123) "123")
  114. (test '("~:d" 1234) "1,234")
  115. (test '("~:d" 12345) "12,345")
  116. (test '("~:d" 123456) "123,456")
  117. (test '("~:d" 12345678) "12,345,678")
  118. (test '("~:d" -123) "-123")
  119. (test '("~:d" -1234) "-1,234")
  120. (test '("~:d" -12345) "-12,345")
  121. (test '("~:d" -123456) "-123,456")
  122. (test '("~:d" -12345678) "-12,345,678")
  123. (test '("~10:d" 1234) "     1,234")
  124. (test '("~10:d" -1234) "    -1,234")
  125. (test '("~10,'*d" 100) "*******100")
  126. (test '("~10,,'|:d" 12345678) "12|345|678")
  127. (test '("~10,,,2:d" 12345678) "12,34,56,78")
  128. (test '("~14,'*,'|,4:@d" 12345678) "****+1234|5678")
  129. (test '("~10r" 100) "100")
  130. (test '("~2r" 100) "1100100")
  131. (test '("~8r" 100) "144")
  132. (test '("~16r" 100) "64")
  133. (test '("~16,10,'*r" 100) "********64")
  134.  
  135. ; roman numeral test
  136.  
  137. (test '("~@r" 4) "IV")
  138. (test '("~@r" 19) "XIX")
  139. (test '("~@r" 50) "L")
  140. (test '("~@r" 100) "C")
  141. (test '("~@r" 1000) "M")
  142. (test '("~@r" 99) "XCIX")
  143. (test '("~@r" 1994) "MCMXCIV")
  144.  
  145. ; old roman numeral test
  146.  
  147. (test '("~:@r" 4) "IIII")
  148. (test '("~:@r" 5) "V")
  149. (test '("~:@r" 10) "X")
  150. (test '("~:@r" 9) "VIIII")
  151.  
  152. ; cardinal/ordinal English number test
  153.  
  154. (test '("~r" 4) "four")
  155. (test '("~r" 10) "ten")
  156. (test '("~r" 19) "nineteen")
  157. (test '("~r" 1984) "one thousand, nine hundred eighty-four")
  158. (test '("~:r" -1984) "minus one thousand, nine hundred eighty-fourth")
  159.  
  160. ; character test
  161.  
  162. (test '("~c" #\a) "a")
  163. (test '("~@c" #\a) "#\\a")
  164. (test `("~@c" ,(integer->char 32)) "#\\space")
  165. (test `("~@c" ,(integer->char 0)) "#\\nul")
  166. (test `("~@c" ,(integer->char 27)) "#\\esc")
  167. (test `("~@c" ,(integer->char 127)) "#\\del")
  168. (test `("~@c" ,(integer->char 128)) "#\\200")
  169. (test `("~@c" ,(integer->char 255)) "#\\377")
  170. (test '("~65c") "A")
  171. (test '("~7@c") "#\\bel")
  172. (test '("~:c" #\a) "a")
  173. (test `("~:c" ,(integer->char 1)) "^A")
  174. (test `("~:c" ,(integer->char 27)) "^[")
  175. (test '("~7:c") "^G")
  176. (test `("~:c" ,(integer->char 128)) "#\\200")
  177. (test `("~:c" ,(integer->char 127)) "#\\177")
  178. (test `("~:c" ,(integer->char 255)) "#\\377")
  179.  
  180.  
  181. ; plural test
  182.  
  183. (test '("test~p" 1) "test")
  184. (test '("test~p" 2) "tests")
  185. (test '("test~p" 0) "tests")
  186. (test '("tr~@p" 1) "try")
  187. (test '("tr~@p" 2) "tries")
  188. (test '("tr~@p" 0) "tries")
  189. (test '("~a test~:p" 10) "10 tests")
  190. (test '("~a test~:p" 1) "1 test")
  191.  
  192. ; tilde test
  193.  
  194. (test '("~~~~") "~~")
  195. (test '("~3~") "~~~")
  196.  
  197. ; whitespace character test
  198.  
  199. (test '("~%") "
  200. ")
  201. (test '("~3%") "
  202.  
  203.  
  204. ")
  205. (test '("~&") "")
  206. (test '("abc~&") "abc
  207. ")
  208. (test '("abc~&def") "abc
  209. def")
  210. (test '("~&") "
  211. ")
  212. (test '("~3&") "
  213.  
  214. ")
  215. (test '("abc~3&") "abc
  216.  
  217.  
  218. ")
  219. (test '("~|") (string slib:form-feed))
  220. (test '("~_~_~_") "   ")
  221. (test '("~3_") "   ")
  222. (test '("~/") (string slib:tab))
  223. (test '("~3/") (make-string 3 slib:tab))
  224.  
  225. ; tabulate test
  226.  
  227. (test '("~0&~3t") "   ")
  228. (test '("~0&~10t") "          ")
  229. (test '("~10t") "")
  230. (test '("~0&1234567890~,8tABC")  "1234567890       ABC")
  231. (test '("~0&1234567890~0,8tABC") "1234567890      ABC")
  232. (test '("~0&1234567890~1,8tABC") "1234567890       ABC")
  233. (test '("~0&1234567890~2,8tABC") "1234567890ABC")
  234. (test '("~0&1234567890~3,8tABC") "1234567890 ABC")
  235. (test '("~0&1234567890~4,8tABC") "1234567890  ABC")
  236. (test '("~0&1234567890~5,8tABC") "1234567890   ABC")
  237. (test '("~0&1234567890~6,8tABC") "1234567890    ABC")
  238. (test '("~0&1234567890~7,8tABC") "1234567890     ABC")
  239. (test '("~0&1234567890~8,8tABC") "1234567890      ABC")
  240. (test '("~0&1234567890~9,8tABC") "1234567890       ABC")
  241. (test '("~0&1234567890~10,8tABC") "1234567890ABC")
  242. (test '("~0&1234567890~11,8tABC") "1234567890 ABC")
  243. (test '("~0&12345~,8tABCDE~,8tXYZ") "12345    ABCDE   XYZ")
  244. (test '("~,8t+++~,8t===") "     +++     ===")
  245. (test '("~0&ABC~,8,'.tDEF") "ABC......DEF")
  246. (test '("~0&~3,8@tABC") "        ABC")
  247. (test '("~0&1234~3,8@tABC") "1234    ABC")
  248. (test '("~0&12~3,8@tABC~3,8@tDEF") "12      ABC     DEF")
  249.  
  250. ; indirection test
  251.  
  252. (test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40")
  253. (test '("~a ~@? ~a" 10 "~a ~a" 20 30 40) "10 20 30 40")
  254.  
  255. ; field test
  256.  
  257. (test '("~10a" "abc") "abc       ")
  258. (test '("~10@a" "abc") "       abc")
  259. (test '("~10a" "0123456789abc") "0123456789abc")
  260. (test '("~10@a" "0123456789abc") "0123456789abc")
  261.  
  262. ; pad character test
  263.  
  264. (test '("~10,,,'*a" "abc") "abc*******")
  265. (test '("~10,,,'Xa" "abc") "abcXXXXXXX")
  266. (test '("~10,,,42a" "abc") "abc*******")
  267. (test '("~10,,,'*@a" "abc") "*******abc")
  268. (test '("~10,,3,'*a" "abc") "abc*******")
  269. (test '("~10,,3,'*a" "0123456789abc") "0123456789abc***") ; min. padchar length
  270. (test '("~10,,3,'*@a" "0123456789abc") "***0123456789abc")
  271.  
  272. ; colinc, minpad padding test
  273.  
  274. (test '("~10,8,0,'*a" 123)  "123********")
  275. (test '("~10,9,0,'*a" 123)  "123*********")
  276. (test '("~10,10,0,'*a" 123) "123**********")
  277. (test '("~10,11,0,'*a" 123) "123***********")
  278. (test '("~8,1,0,'*a" 123) "123*****")
  279. (test '("~8,2,0,'*a" 123) "123******")
  280. (test '("~8,3,0,'*a" 123) "123******")
  281. (test '("~8,4,0,'*a" 123) "123********")
  282. (test '("~8,5,0,'*a" 123) "123*****")
  283. (test '("~8,1,3,'*a" 123) "123*****")
  284. (test '("~8,1,5,'*a" 123) "123*****")
  285. (test '("~8,1,6,'*a" 123) "123******")
  286. (test '("~8,1,9,'*a" 123) "123*********")
  287.  
  288. ; slashify test
  289.  
  290. (test '("~s" "abc") "\"abc\"")
  291. (test '("~s" "abc \\ abc") "\"abc \\\\ abc\"")
  292. (test '("~a" "abc \\ abc") "abc \\ abc")
  293. (test '("~s" "abc \" abc") "\"abc \\\" abc\"")
  294. (test '("~a" "abc \" abc") "abc \" abc")
  295. (test '("~s" #\space) "#\\space")
  296. (test '("~s" #\newline) "#\\newline")
  297. (test '("~s" #\tab) "#\\ht")
  298. (test '("~s" #\a) "#\\a")
  299. (test '("~a" (a "b" c)) "(a \"b\" c)")
  300.  
  301. ; symbol case force test
  302.  
  303. (define format:old-scc format:symbol-case-conv)
  304. (set! format:symbol-case-conv string-upcase)
  305. (test '("~a" abc) "ABC")
  306. (set! format:symbol-case-conv string-downcase)
  307. (test '("~s" abc) "abc")
  308. (set! format:symbol-case-conv string-capitalize)
  309. (test '("~s" abc) "Abc")
  310. (set! format:symbol-case-conv format:old-scc)
  311.  
  312. ; read proof test
  313.  
  314. (test `("~:s" ,display)
  315.       (begin
  316.     (set! format:read-proof #t)
  317.     (format:iobj->str display)))
  318. (test `("~:a" ,display)
  319.       (begin
  320.     (set! format:read-proof #t)
  321.     (format:iobj->str display)))
  322. (test `("~:a" (1 2 ,display))
  323.       (begin
  324.     (set! format:read-proof #t)
  325.     (string-append "(1 2 " (format:iobj->str display) ")")))
  326. (test '("~:a" "abc") "abc")
  327. (set! format:read-proof #f)
  328.  
  329. ; internal object case type force test
  330.  
  331. (set! format:iobj-case-conv string-upcase)
  332. (test `("~a" ,display) (string-upcase (format:iobj->str display)))
  333. (set! format:iobj-case-conv string-downcase)
  334. (test `("~s" ,display) (string-downcase (format:iobj->str display)))
  335. (set! format:iobj-case-conv string-capitalize)
  336. (test `("~s" ,display) (string-capitalize (format:iobj->str display)))
  337. (set! format:iobj-case-conv #f)
  338.  
  339. ; continuation line test
  340.  
  341. (test '("abc~
  342.          123") "abc123")
  343. (test '("abc~
  344. 123") "abc123")
  345. (test '("abc~
  346. ") "abc")
  347. (test '("abc~:
  348.          def") "abc         def")
  349. (test '("abc~@
  350.          def")
  351. "abc
  352. def")
  353.  
  354. ; flush output (can't test it here really)
  355.  
  356. (test '("abc ~! xyz") "abc  xyz")
  357.  
  358. ; string case conversion
  359.  
  360. (test '("~a ~(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc hello world xyz")
  361. (test '("~a ~:(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello World xyz")
  362. (test '("~a ~@(~a~) ~a" "abc" "HELLO WORLD" "xyz") "abc Hello world xyz")
  363. (test '("~a ~:@(~a~) ~a" "abc" "hello world" "xyz") "abc HELLO WORLD xyz")
  364. (test '("~:@(~a~)" (a b c)) "(A B C)")
  365. (test '("~:@(~x~)" 255) "FF")
  366. (test '("~:@(~p~)" 2) "S")
  367. (test `("~:@(~a~)" ,display) (string-upcase (format:iobj->str display)))
  368. (test '("~:(~a ~a ~a~) ~a" "abc" "xyz" "123" "world") "Abc Xyz 123 world")
  369.  
  370. ; variable parameter
  371.  
  372. (test '("~va" 10 "abc") "abc       ")
  373. (test '("~v,,,va" 10 42 "abc") "abc*******")
  374.  
  375. ; number of remaining arguments as parameter
  376.  
  377. (test '("~#,,,'*@a ~a ~a ~a" 1 1 1 1) "***1 1 1 1")
  378.  
  379. ; argument jumping
  380.  
  381. (test '("~a ~* ~a" 10 20 30) "10  30")
  382. (test '("~a ~2* ~a" 10 20 30 40) "10  40")
  383. (test '("~a ~:* ~a" 10) "10  10")
  384. (test '("~a ~a ~2:* ~a ~a" 10 20) "10 20  10 20")
  385. (test '("~a ~a ~@* ~a ~a" 10 20) "10 20  10 20")
  386. (test '("~a ~a ~4@* ~a ~a" 10 20 30 40 50 60) "10 20  50 60")
  387.  
  388. ; conditionals
  389.  
  390. (test '("~[abc~;xyz~]" 0) "abc")
  391. (test '("~[abc~;xyz~]" 1) "xyz")
  392. (test '("~[abc~;xyz~:;456~]" 99) "456")
  393. (test '("~0[abc~;xyz~:;456~]") "abc")
  394. (test '("~1[abc~;xyz~:;456~] ~a" 100) "xyz 100")
  395. (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]") "no arg")
  396. (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10) "10")
  397. (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20) "10 and 20")
  398. (test '("~#[no arg~;~a~;~a and ~a~;~a, ~a and ~a~]" 10 20 30) "10, 20 and 30")
  399. (test '("~:[hello~;world~] ~a" #t 10) "world 10")
  400. (test '("~:[hello~;world~] ~a" #f 10) "hello 10")
  401. (test '("~@[~a tests~]" #f) "")
  402. (test '("~@[~a tests~]" 10) "10 tests")
  403. (test '("~@[~a test~:p~] ~a" 10 done) "10 tests done")
  404. (test '("~@[~a test~:p~] ~a" 1 done) "1 test done")
  405. (test '("~@[~a test~:p~] ~a" 0 done) "0 tests done")
  406. (test '("~@[~a test~:p~] ~a" #f done) " done")
  407. (test '("~@[ level = ~d~]~@[ length = ~d~]" #f 5) " length = 5")
  408. (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 0) "abc")   ; nested conditionals (irrghh)
  409. (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 2) "xyz")
  410. (test '("~[abc~;~[4~;5~;6~]~;xyz~]" 1 2) "6")
  411.  
  412. ; iteration
  413.  
  414. (test '("~{ ~a ~}" (a b c)) " a  b  c ")
  415. (test '("~{ ~a ~}" ()) "")
  416. (test '("~{ ~a ~5,,,'*a~}" (a b c d)) " a b**** c d****")
  417. (test '("~{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1  b,2  c,3 ")
  418. (test '("~2{ ~a,~a ~}" (a 1 b 2 c 3)) " a,1  b,2 ")
  419. (test '("~3{~a ~} ~a" (a b c d e) 100) "a b c  100")
  420. (test '("~0{~a ~} ~a" (a b c d e) 100) " 100")
  421. (test '("~:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b  c,d  g,h ")
  422. (test '("~2:{ ~a,~a ~}" ((a b) (c d e f) (g h))) " a,b  c,d ")
  423. (test '("~@{ ~a,~a ~}" a 1 b 2 c 3) " a,1  b,2  c,3 ")
  424. (test '("~2@{ ~a,~a ~} <~a|~a>" a 1 b 2 c 3) " a,1  b,2  <c|3>")
  425. (test '("~:@{ ~a,~a ~}" (a 1) (b 2) (c 3)) " a,1  b,2  c,3 ")
  426. (test '("~2:@{ ~a,~a ~} ~a" (a 1) (b 2) (c 3)) " a,1  b,2  (c 3)")
  427. (test '("~{~}" "<~a,~a>" (a 1 b 2 c 3)) "<a,1><b,2><c,3>")
  428. (test '("~{ ~a ~{<~a>~}~} ~a" (a (1 2) b (3 4)) 10) " a <1><2> b <3><4> 10")
  429.  
  430. ; up and out
  431.  
  432. (test '("abc ~^ xyz") "abc ")
  433. (test '("~@(abc ~^ xyz~) ~a" 10) "ABC  xyz 10")
  434. (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p.") "done. ")
  435. (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10) "done.  10 warnings. ")
  436. (test '("done. ~^ ~d warning~:p. ~^ ~d error~:p." 10 1)
  437.       "done.  10 warnings.  1 error.")
  438. (test '("~{ ~a ~^<~a>~} ~a" (a b c d e f) 10) " a <b> c <d> e <f> 10")
  439. (test '("~{ ~a ~^<~a>~} ~a" (a b c d e) 10) " a <b> c <d> e  10")
  440. (test '("abc~0^ xyz") "abc")
  441. (test '("abc~9^ xyz") "abc xyz")
  442. (test '("abc~7,4^ xyz") "abc xyz")
  443. (test '("abc~7,7^ xyz") "abc")
  444. (test '("abc~3,7,9^ xyz") "abc")
  445. (test '("abc~8,7,9^ xyz") "abc xyz")
  446. (test '("abc~3,7,5^ xyz") "abc xyz")
  447.  
  448. ; complexity tests (oh my god, I hardly understand them myself (see CL std))
  449.  
  450. (define fmt "Items:~#[ none~; ~a~; ~a and ~a~:;~@{~#[~; and~] ~a~^,~}~].")
  451.  
  452. (test `(,fmt ) "Items: none.")
  453. (test `(,fmt foo) "Items: foo.")
  454. (test `(,fmt foo bar) "Items: foo and bar.")
  455. (test `(,fmt foo bar baz) "Items: foo, bar, and baz.")
  456. (test `(,fmt foo bar baz zok) "Items: foo, bar, baz, and zok.")
  457.  
  458. ; fixed floating points
  459.  
  460. (cond
  461.  (format:floats
  462.   (test '("~6,2f" 3.14159) "  3.14")
  463.   (test '("~6,1f" 3.14159) "   3.1")
  464.   (test '("~6,0f" 3.14159) "    3.")
  465.   (test '("~5,1f" 0) "  0.0")
  466.   (test '("~10,7f" 3.14159) " 3.1415900")
  467.   (test '("~10,7f" -3.14159) "-3.1415900")
  468.   (test '("~10,7@f" 3.14159) "+3.1415900")
  469.   (test '("~6,3f" 0.0) " 0.000")
  470.   (test '("~6,4f" 0.007) "0.0070")
  471.   (test '("~6,3f" 0.007) " 0.007")
  472.   (test '("~6,2f" 0.007) "  0.01")
  473.   (test '("~3,2f" 0.007) ".01")
  474.   (test '("~3,2f" -0.007) "-.01")
  475.   (test '("~6,2,,,'*f" 3.14159) "**3.14")
  476.   (test '("~6,3,,'?f" 12345.56789) "??????")
  477.   (test '("~6,3f" 12345.6789) "12345.679")
  478.   (test '("~,3f" 12345.6789) "12345.679")
  479.   (test '("~,3f" 9.9999) "10.000")
  480.   (test '("~6f" 23.4) "  23.4")
  481.   (test '("~6f" 1234.5) "1234.5")
  482.   (test '("~6f" 12345678) "12345678.0")
  483.   (test '("~6,,,'?f" 12345678) "??????")
  484.   (test '("~6f" 123.56789) "123.57")
  485.   (test '("~6f" 123.0) " 123.0")
  486.   (test '("~6f" -123.0) "-123.0")
  487.   (test '("~6f" 0.0) "   0.0")
  488.   (test '("~3f" 3.141) "3.1")
  489.   (test '("~2f" 3.141) "3.")
  490.   (test '("~1f" 3.141) "3.141")
  491.   (test '("~f" 123.56789) "123.56789")
  492.   (test '("~f" -314.0) "-314.0")
  493.   (test '("~f" 1e4) "10000.0")
  494.   (test '("~f" -1.23e10) "-12300000000.0")
  495.   (test '("~f" 1e-4) "0.0001")
  496.   (test '("~f" -1.23e-10) "-0.000000000123")
  497.   (test '("~@f" 314.0) "+314.0")
  498.   (test '("~,,3f" 0.123456) "123.456")
  499.   (test '("~,,-3f" -123.456) "-0.123456")
  500.   (test '("~5,,3f" 0.123456) "123.5")
  501. ))
  502.  
  503. ; exponent floating points
  504.  
  505. (cond
  506.  (format:floats
  507.   (test '("~e" 3.14159) "3.14159E+0")
  508.   (test '("~e" 0.00001234) "1.234E-5")
  509.   (test '("~,,,0e" 0.00001234) "0.1234E-4")
  510.   (test '("~,3e" 3.14159) "3.142E+0")
  511.   (test '("~,3@e" 3.14159) "+3.142E+0")
  512.   (test '("~,3@e" 0.0) "+0.000E+0")
  513.   (test '("~,0e" 3.141) "3.E+0")
  514.   (test '("~,3,,0e" 3.14159) "0.314E+1")
  515.   (test '("~,5,3,-2e" 3.14159) "0.00314E+003")
  516.   (test '("~,5,3,-5e" -3.14159) "-0.00000E+006")
  517.   (test '("~,5,2,2e" 3.14159) "31.4159E-01")
  518.   (test '("~,5,2,,,,'ee" 0.0) "0.00000e+00")
  519.   (test '("~12,3e" -3.141) "   -3.141E+0")
  520.   (test '("~12,3,,,,'#e" -3.141) "###-3.141E+0")
  521.   (test '("~10,2e" -1.236e-4) "  -1.24E-4")
  522.   (test '("~5,3e" -3.141) "-3.141E+0")
  523.   (test '("~5,3,,,'*e" -3.141) "*****")
  524.   (test '("~3e" 3.14159) "3.14159E+0")
  525.   (test '("~4e" 3.14159) "3.14159E+0")
  526.   (test '("~5e" 3.14159) "3.E+0")
  527.   (test '("~5,,,,'*e" 3.14159) "3.E+0")
  528.   (test '("~6e" 3.14159) "3.1E+0")
  529.   (test '("~7e" 3.14159) "3.14E+0")
  530.   (test '("~7e" -3.14159) "-3.1E+0")
  531.   (test '("~8e" 3.14159) "3.142E+0")
  532.   (test '("~9e" 3.14159) "3.1416E+0")
  533.   (test '("~9,,,,,,'ee" 3.14159) "3.1416e+0")
  534.   (test '("~10e" 3.14159) "3.14159E+0")
  535.   (test '("~11e" 3.14159) " 3.14159E+0")
  536.   (test '("~12e" 3.14159) "  3.14159E+0")
  537.   (test '("~13,6,2,-5e" 3.14159) " 0.000003E+06")
  538.   (test '("~13,6,2,-4e" 3.14159) " 0.000031E+05")
  539.   (test '("~13,6,2,-3e" 3.14159) " 0.000314E+04")
  540.   (test '("~13,6,2,-2e" 3.14159) " 0.003142E+03")
  541.   (test '("~13,6,2,-1e" 3.14159) " 0.031416E+02")
  542.   (test '("~13,6,2,0e" 3.14159)  " 0.314159E+01")
  543.   (test '("~13,6,2,1e" 3.14159)  " 3.141590E+00")
  544.   (test '("~13,6,2,2e" 3.14159)  " 31.41590E-01")
  545.   (test '("~13,6,2,3e" 3.14159)  " 314.1590E-02")
  546.   (test '("~13,6,2,4e" 3.14159)  " 3141.590E-03")
  547.   (test '("~13,6,2,5e" 3.14159)  " 31415.90E-04")
  548.   (test '("~13,6,2,6e" 3.14159)  " 314159.0E-05")
  549.   (test '("~13,6,2,7e" 3.14159)  " 3141590.E-06")
  550.   (test '("~13,6,2,8e" 3.14159)  "31415900.E-07")
  551.   (test '("~7,3,,-2e" 0.001) ".001E+0")
  552.   (test '("~8,3,,-2@e" 0.001) "+.001E+0")
  553.   (test '("~8,3,,-2@e" -0.001) "-.001E+0")
  554.   (test '("~8,3,,-2e" 0.001) "0.001E+0")
  555.   (test '("~7,,,-2e" 0.001) "0.00E+0")
  556.   (test '("~12,3,1e" 3.14159e12) "   3.142E+12")
  557.   (test '("~12,3,1,,'*e" 3.14159e12) "************")
  558.   (test '("~5,3,1e" 3.14159e12) "3.142E+12")
  559. ))
  560.  
  561. ; general floating point (this test is from Steele's CL book)
  562.  
  563. (cond
  564.  (format:floats
  565.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  566.       0.0314159 0.0314159 0.0314159 0.0314159)
  567.     "  3.14E-2|314.2$-04|0.314E-01|  3.14E-2")
  568.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  569.       0.314159 0.314159 0.314159 0.314159)
  570.     "  0.31   |0.314    |0.314    | 0.31    ")
  571.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  572.       3.14159 3.14159 3.14159 3.14159)
  573.     "   3.1   | 3.14    | 3.14    |  3.1    ")
  574.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  575.       31.4159 31.4159 31.4159 31.4159)
  576.     "   31.   | 31.4    | 31.4    |  31.    ")
  577.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  578.       314.159 314.159 314.159 314.159)
  579.     "  3.14E+2| 314.    | 314.    |  3.14E+2") 
  580.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  581.       3141.59 3141.59 3141.59 3141.59)
  582.     "  3.14E+3|314.2$+01|0.314E+04|  3.14E+3")
  583.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  584.       3.14E12 3.14E12 3.14E12 3.14E12)
  585.     "*********|314.0$+10|0.314E+13| 3.14E+12")
  586.   (test '("~9,2,1,,'*g|~9,3,2,3,'?,,'$g|~9,3,2,0,'%g|~9,2g"
  587.       3.14E120 3.14E120 3.14E120 3.14E120)
  588.     "*********|?????????|%%%%%%%%%|3.14E+120")
  589.   
  590.   (test '("~g" 0.0) "0.0    ")        ; further ~g tests 
  591.   (test '("~g" 0.1) "0.1    ")
  592.   (test '("~g" 0.01) "1.0E-2")
  593.   (test '("~g" 123.456) "123.456    ")
  594.   (test '("~g" 123456.7) "123456.7    ")
  595.   (test '("~g" 123456.78) "123456.78    ")
  596.   (test '("~g" 0.9282) "0.9282    ")
  597.   (test '("~g" 0.09282) "9.282E-2")
  598.   (test '("~g" 1) "1.0    ")
  599.   (test '("~g" 12) "12.0    ")
  600.   ))
  601.  
  602. ; dollar floating point
  603.  
  604. (cond
  605.  (format:floats
  606.   (test '("~$" 1.23) "1.23")
  607.   (test '("~$" 1.2) "1.20")
  608.   (test '("~$" 0.0) "0.00")
  609.   (test '("~$" 9.999) "10.00")
  610.   (test '("~3$" 9.9999) "10.000")
  611.   (test '("~,4$" 3.2) "0003.20")
  612.   (test '("~,4$" 10000.2) "10000.20")
  613.   (test '("~,4,10$" 3.2) "   0003.20")
  614.   (test '("~,4,10@$" 3.2) "  +0003.20")
  615.   (test '("~,4,10:@$" 3.2) "+  0003.20")
  616.   (test '("~,4,10:$" -3.2) "-  0003.20")
  617.   (test '("~,4,10$" -3.2) "  -0003.20")
  618.   (test '("~,,10@$" 3.2) "     +3.20")
  619.   (test '("~,,10:@$" 3.2) "+     3.20")
  620.   (test '("~,,10:@$" -3.2) "-     3.20")
  621.   (test '("~,,10,'_@$" 3.2) "_____+3.20")
  622.   (test '("~,,4$" 1234.4) "1234.40")
  623. ))
  624.  
  625. ; complex numbers
  626.  
  627. (cond 
  628.  (format:complex-numbers
  629.   (test '("~i" 3.0) "3.0+0.0i")
  630.   (test '("~,3i" 3.0) "3.000+0.000i")
  631.   (test `("~7,2i" ,(string->number "3.0+5.0i")) "   3.00  +5.00i")
  632.   (test `("~7,2,1i" ,(string->number "3.0+5.0i")) "  30.00 +50.00i")
  633.   (test `("~7,2@i" ,(string->number "3.0+5.0i")) "  +3.00  +5.00i")
  634.   (test `("~7,2,,,'*@i" ,(string->number "3.0+5.0i")) "**+3.00**+5.00i")
  635.   )) ; note: some parsers choke syntactically on reading a complex
  636.      ; number though format:complex is #f; this is why we put them in
  637.      ; strings 
  638.  
  639. ; inquiry test
  640.  
  641. (test '("~:q") format:version)
  642.  
  643. (if (not test-verbose) (display "done."))
  644.  
  645. (format #t "~%~a Test~:p completed. (~a failure~:p)~2%" total fails)
  646.  
  647. ; eof
  648.